Enigma Amiga Life 109/EnigmaAmiga109CD.iso/dalla rivista/amiga.free/sorgenti vari/wolfedit2 2.0.4 source.sit/WolfEdit2 2.0.4 Source/UCreateLevel.p

Text File | 1995-12-07 | 13KB | 506 lines

unit UCreateLevel;

interface
    uses
        ULevel, UWolfDoc;

    type

        ObjectCountRecord = record
                numObjects: integer;
                objectBytes: longint;
                numGuards: integer;
                numTreasures: integer;
                numDoors: integer;
                numSecretDoors: integer;
                numRooms: integer;
                numSprites: integer;
                numSpritesInRoom: array[0..63] of integer;
            end;

    function CreateLevelFromMap (map: TMapCells; var h: LevelHandle; name: string; checkLimits: boolean): OSErr;
    procedure CalculateStatistics (map: TMapCells; var stats: ObjectCountRecord);

implementation
    uses
        UBSP;

    const

        noRequiredItemsAlrtID = 132;
        tooManyRoomsAlrtID = 134;
        tooManyThingsAlrtID = 138;

        soundAreaMarkerFlag = 1;

{$D-}
{$R-}

    function CheckNonzeroCounts (counts: ObjectCountRecord; name: string): OSErr;
        var
            n: integer;
            s: string;

        procedure Check (count: integer; what: string);
        begin
            if count = 0 then begin
                    case n of
                        0:
                            s := what;
                        1:
                            s := concat(what, ' or ', s);
                        otherwise
                            s := concat(what, ', ', s);
                    end;
                    n := n + 1;
                end;
        end;

    begin
        with counts do begin
                n := 0;
                s := '';
                Check(numSecretDoors, 'secret doors');
                Check(numTreasures, 'treasures');
                Check(numGuards, 'guards');
                if n > 0 then begin
                        ParamText(name, s, '', '');
                        if Ask(noRequiredItemsAlrtID) = ok then
                            CheckNonzeroCounts := noErr
                        else
                            CheckNonzeroCounts := suppressErr;
                    end
                else
                    CheckNonzeroCounts := noErr;
            end;
    end;

{$PUSH}
{$D+}
    function CheckCountLimits (counts: ObjectCountRecord; name: string; checkSprites: boolean): OSErr;
        var
            i: integer;

        procedure Check (count, limit: integer; what: string);
        begin
            if count > limit then begin
                    ParamText(name, what, StringOf(limit : 1), StringOf(count : 1));
                    if Ask(tooManyThingsAlrtID) = cancel then begin
                            CheckCountLimits := suppressErr;
                            exit(CheckCountLimits);
                        end;
                end;
        end;

    begin
        with counts do begin
                Check(numSecretDoors, 64, 'too many secret doors');
                Check(numDoors, 64, 'too many doors');
                if checkSprites then begin
                        Check(numSprites - numGuards, 200, 'too many objects');
                        Check(numGuards, 127, 'too many guards');
                        for i := 0 to 63 do
                            Check(numSpritesInRoom[i], 64, 'a room with too many objects or guards');
                    end;
            end;
        CheckCountLimits := noErr;
    end;
{$D-}

    procedure CountObjects (var map: MapCellGrid; var info: ObjectCountRecord);
        var
            row, col, room, i: integer;
            code: MapCell;
    begin
        with info do begin
                numObjects := 0;
                objectBytes := 0;
                numGuards := 0;
                numTreasures := 0;
                numDoors := 0;
                numSecretDoors := 0;
                numSprites := 0;
                for i := 0 to 63 do
                    numSpritesInRoom[i] := 0;
                for row := 0 to 63 do
                    for col := 0 to 63 do begin
                            code := map[row, col];
                            if IsObject(code) then begin
                                    numObjects := numObjects + 1;
                                    objectBytes := objectBytes + 3;
                                    room := map[row, col].area;
                                    if IsDoor(code) then
                                        numDoors := numDoors + 1
                                    else if IsSecretDoor(code) then begin
                                            objectBytes := objectBytes + 1;
                                            numSecretDoors := numSecretDoors + 1;
                                        end
                                    else if code.obj >= firstObjectCode then begin
                                            numSprites := numSprites + 1;
                                            if (room >= 0) & (room <= 63) then
                                                numSpritesInRoom[room] := numSpritesInRoom[room] + 1;
                                            if IsGuard(code) then
                                                numGuards := numGuards + 1
                                            else if IsTreasure(code) then
                                                numTreasures := numTreasures + 1;
                                        end;
                                end;
                            if (code.wall >= 1) and (code.wall <= 64) then {sound area marker}
                                objectBytes := objectBytes + 3;
                            if code.missingQuarters <> 0 then {quartering marker}
                                objectBytes := objectBytes + 3;
                        end;
            end;
    end;

{$PUSH}
{$D+}
{$R+}
    procedure FillRoom (var map: MapCellGrid; row, col, room, inMask: integer);
        var
            code: MapCell;
            mq: integer;
    begin
        with map[row, col] do
            if area = $7F then
                if (wall < $80) or (obj = $62) then begin
                        area := room;
                        if row > 0 then
                            FillRoom(map, row - 1, col, room, $C);
                        if row < 63 then
                            FillRoom(map, row + 1, col, room, $3);
                        if col > 0 then
                            FillRoom(map, row, col - 1, room, $A);
                        if col < 63 then
                            FillRoom(map, row, col + 1, room, $5);
                    end
                else if BAND(missingQuarters, inMask) <> 0 then begin
                        area := room;
                        mq := missingQuarters;
                        if (row > 0) and (BAND(mq, $3) <> 0) then
                            FillRoom(map, row - 1, col, room, BAND($C, BSL(mq, 2)));
                        if (row < 63) and (BAND(mq, $C) <> 0) then
                            FillRoom(map, row + 1, col, room, BAND($3, BSR(mq, 2)));
                        if (col > 0) and (BAND(mq, $5) <> 0) then
                            FillRoom(map, row, col - 1, room, BAND($A, BSL(mq, 1)));
                        if (col < 63) and (BAND(mq, $A) <> 0) then
                            FillRoom(map, row, col + 1, room, BAND($5, BSR(mq, 1)));
                    end;
    end;
{$POP}

{CalculateRooms allocates room numbers and set the area field of each cell to the}
{room number of the room to which it belongs, or $40 if it does not belong to a room.}
{It converts each sound area marker by moving the sound area number into the wall field.}

{$PUSH}
{$D+}
{$R+}
    function CalculateRooms (var map: MapCellGrid): OSErr;
        var
            row, col: integer;
            nextRoom: integer;
            code: MapCell;
    begin
        CalculateRooms := noErr;
    {Mark empty space with $7F and solid space with $40}
        for row := 0 to 63 do
            for col := 0 to 63 do
                with map[row, col] do begin
                        if area > 0 then
                            wall := area;
                        if (wall < $80) or (obj = $62) or (missingQuarters <> 0) then
                            area := $7F
                        else
                            area := $40;
                    end;
    {Flood-fill each contiguous $7F region with a unique room number}
        nextRoom := 0;
        for row := 0 to 63 do
            for col := 0 to 63 do begin
                    if map[row, col].area = $7F then begin
                            FillRoom(map, row, col, BAND(nextRoom, $3F), $F);
                            nextRoom := nextRoom + 1;
                        end;
                end;
        CalculateRooms := nextRoom;
    end;
{$D-}

{$PUSH}
{$D+}
    function CalcAndCheckRooms (var map: MapCellGrid; name: string): OSErr;
        var
            numRooms: integer;
    begin
        CalcAndCheckRooms := noErr;
        numRooms := CalculateRooms(map);
        if numRooms > 64 then begin
                ParamText(name, StringOf(numRooms : 1), '', '');
                if Ask(tooManyRoomsAlrtID) = cancel then
                    CalcAndCheckRooms := suppressErr;
            end;
    end;
{$POP}

    procedure PutWallArray (h: LevelHandle; var map: MapCellGrid);
        var
            row, col, item: integer;
    begin
        for row := 0 to 63 do
            for col := 0 to 63 do begin
                    with map[row, col] do begin
                            if (wall >= $80) and (obj <> $62) then
                                item := wall
                            else
                                item := area;
                        end;
                    h^^.map[row, col] := item;
                end;
    end;

{For each room containing a sound marker, give it the sound area}
{number of its marker. Then assign unused sound area numbers to the}
{remaining rooms.}

    procedure PutSoundAreaTable (h: LevelHandle; var map: MapCellGrid);
        type
            Set64 = set of 0..63;
        var
            roomsDone, areasUsed: Set64;
            row, col, room, area: integer;
    begin
        roomsDone := [];
        areasUsed := [];
        for row := 0 to 63 do
            for col := 0 to 63 do begin
                    area := map[row, col].wall;
                    if (area >= 1) & (area <= 64) then begin
                            area := area - 1;
                            room := map[row, col].area;
                            if room <= 63 then begin
                                    h^^.zones[room] := area;
                                    roomsDone := roomsDone + [room];
                                    areasUsed := areasUsed + [area];
                                end;
                        end;
                end;
        area := 0;
        for room := 0 to 63 do
            if not (room in roomsDone) then begin
                    while (area < 64) & (area in areasUsed) do
                        area := area + 1;
                    if area < 64 then begin
                            areasUsed := areasUsed + [area];
                            h^^.zones[room] := area;
                        end
                    else {shouldn't happen, but just in case}
                        h^^.zones[room] := 0;
                end;
    end;

    procedure PutOffsetTable (h: LevelHandle; numObjects: integer; objectBytes: longint; numBSPEntries: integer);
        var
            objOffset, bspOffset: longint;
    begin
        objOffset := 64 * 64 + 64 + 8;
        bspOffset := objOffset + objectBytes;
        SetLittleEndian(h^^.numObjects, numObjects);
        SetLittleEndian(h^^.objOffset, objOffset);
        SetLittleEndian(h^^.numBSPEntries, numBSPEntries);
        SetLittleEndian(h^^.bspOffset, bspOffset);
    end;

    procedure PutObjectTable (h: LevelHandle; var map: MapCellGrid);
        var
            obj: ObjectEntry;
            p: longint;
            row, col: integer;
            code: MapCell;
    begin
        p := 0;
        for row := 0 to 63 do
            for col := 0 to 63 do begin
                    code := map[row, col];
                    obj.x := col;
                    obj.y := row;
                    if IsObject(code) then begin
                            obj.code := ExtractObject(code);
                            if obj.code = $62 then
                                obj.code2 := ExtractObjectExtra(code);
                            PutObject(h, p, obj);
                        end;
                    if (code.wall >= 1) and (code.wall <= 64) then begin {sound area marker}
                            obj.code := $FF;
                            PutObject(h, p, obj);
                        end;
                    if code.missingQuarters <> 0 then begin
                            obj.code := $E0 + code.missingQuarters;
                            PutObject(h, p, obj);
                        end;
                end;
    end;

    procedure NumberBSPEntries (tree: BSPTreePtr; var n: integer);

        procedure Number (var i: integer);
        begin
            i := n;
            n := n + 1;
        end;

        procedure NumberTree (p: BSPTreePtr);
            var
                seg: SegmentPtr;
        begin
            case p^.kind of
                nonterminal:  begin
                        Number(p^.entry);
                        NumberTree(p^.links[0]);
                        NumberTree(p^.links[1]);
                    end;
                terminal:  begin
                        p^.entry := n;
                        seg := p^.segments;
                        while seg <> nil do begin
                                Number(seg^.entry);
                                seg := seg^.next;
                            end;
                    end;
            end;
        end;

    begin {NumberBSPEntries}
        n := 0;
        NumberTree(tree);
    end;

    procedure PutNonterminal (lh: LevelHandle; p: BSPTreePtr);
        var
            n, i: integer;
            e: BSPEntry;
            w: LittleEndianWord;
    begin
        n := p^.entry;
        e.coord0 := p^.splitCoord;
        case p^.splitDir of
            h:
                e.flags := bspSplitH;
            v:
                e.flags := bspSplitV;
        end;
        for i := 0 to 1 do begin
                SetLittleEndian(w, p^.links[i]^.entry);
                e.links[i] := w;
            end;
        PutBSPEntry(lh, n, e);
    end;

    procedure PutSegment (lh: LevelHandle; p: SegmentPtr; lastSeg: boolean);
        var
            n, code: integer;
            e: BSPEntry;
    begin
        n := p^.entry;
        e.coord0 := p^.pos;
        case p^.dir of
            h:
                case p^.face of
                    nw:
                        code := bspFaceNorth;
                    se:
                        code := bspFaceSouth;
                end;
            v:
                case p^.face of
                    nw:
                        code := bspFaceWest;
                    se:
                        code := bspFaceEast;
                end;
        end;
        if lastSeg then
            code := code + bspLastSeg;
        e.flags := bspTerminal + code;
        e.coord1 := p^.ends[0];
        e.coord2 := p^.ends[1];
        e.grid := p^.grid;
        e.area := p^.area;
        PutBSPEntry(lh, n, e);
    end;

    procedure PutBSPTree (h: LevelHandle; p: BSPTreePtr);
        var
            seg: SegmentPtr;
    begin
        case p^.kind of
            nonterminal:  begin
                    PutNonterminal(h, p);
                    PutBSPTree(h, p^.links[0]);
                    PutBSPTree(h, p^.links[1]);
                end;
            terminal:  begin
                    seg := p^.segments;
                    while seg <> nil do begin
                            PutSegment(h, seg, seg^.next = nil);
                            seg := seg^.next;
                        end;
                end;
        end;
    end;

    function CreateLevelFromMap (map: TMapCells; var h: LevelHandle; name: string; checkLimits: boolean): OSErr;
        var
            numObjects, numBSPEntries: integer;
            objectBytes, bspBytes, totBytes: longint;
            tree: BSPTreePtr;
            grid: MapCellGrid;
            counts: ObjectCountRecord;

        procedure Check (result: OSErr);
        begin
            if result <> noErr then begin
                    DisposeBSPTree(tree);
                    if h <> nil then
                        DisposeLevel(h);
                    CreateLevelFromMap := result;
                    exit(CreateLevelFromMap);
                end;
        end;

{$D+}
    begin
        h := nil;
        tree := nil;
        map.CopyToGrid(grid);
        Check(CalcAndCheckRooms(grid, name));
        CountObjects(grid, counts);
        Check(CheckNonzeroCounts(counts, name));
        Check(CheckCountLimits(counts, name, checkLimits));
        Check(CreateBSPTree(grid, tree));
        NumberBSPEntries(tree, numBSPEntries);
        bspBytes := 6 * numBSPEntries;
        totBytes := 64 * 64 + 64 + 8 + counts.objectBytes + bspBytes;
        h := LevelHandle(NewHandle(totBytes));
        Check(MemError);
        PutWallArray(h, grid);
        PutSoundAreaTable(h, grid);
        with counts do
            PutOffsetTable(h, (objectBytes - numSecretDoors) div 3, objectBytes, numBSPEntries);
        PutObjectTable(h, grid);
        PutBSPTree(h, tree);
        DisposeBSPTree(tree);
        CreateLevelFromMap := noErr;
    end;

    procedure CalculateStatistics (map: TMapCells; var stats: ObjectCountRecord);
        var
            grid: MapCellGrid;
            result: OSErr;
    begin
        map.CopyToGrid(grid);
        stats.numRooms := CalculateRooms(grid);
        CountObjects(grid, stats);
    end;

end.